home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / lib / perl5 / Net / DBus / Test / MockIterator.pm < prev    next >
Encoding:
Perl POD Document  |  2008-02-20  |  23.5 KB  |  963 lines
  1. # -*- perl -*-
  2. #
  3. # Copyright (C) 2004-2006 Daniel P. Berrange
  4. #
  5. # This program is free software; You can redistribute it and/or modify
  6. # it under the same terms as Perl itself. Either:
  7. #
  8. # a) the GNU General Public License as published by the Free
  9. #   Software Foundation; either version 2, or (at your option) any
  10. #   later version,
  11. #
  12. # or
  13. #
  14. # b) the "Artistic License"
  15. #
  16. # The file "COPYING" distributed along with this file provides full
  17. # details of the terms and conditions of the two licenses.
  18.  
  19. =pod
  20.  
  21. =head1 NAME
  22.  
  23. Net::DBus::Test::MockIterator - Iterator over a mock message
  24.  
  25. =head1 SYNOPSIS
  26.  
  27. Creating a new message
  28.  
  29.   my $msg = new Net::DBus::Test::MockMessage
  30.   my $iterator = $msg->iterator;
  31.  
  32.   $iterator->append_boolean(1);
  33.   $iterator->append_byte(123);
  34.  
  35.  
  36. Reading from a mesage
  37.  
  38.   my $msg = ...get it from somewhere...
  39.   my $iter = $msg->iterator();
  40.  
  41.   my $i = 0;
  42.   while ($iter->has_next()) {
  43.     $iter->next();
  44.     $i++;
  45.     if ($i == 1) {
  46.        my $val = $iter->get_boolean();
  47.     } elsif ($i == 2) {
  48.        my $val = $iter->get_byte();
  49.     }
  50.   }
  51.  
  52. =head1 DESCRIPTION
  53.  
  54. This module provides a "mock" counterpart to the L<Net::DBus::Binding::Iterator>
  55. object which is capable of iterating over mock message objects. Instances of this
  56. module are not created directly, instead they are obtained via the C<iterator>
  57. method on the L<Net::DBus::Test::MockMessage> module.
  58.  
  59. =head1 METHODS
  60.  
  61. =over 4
  62.  
  63. =cut
  64.  
  65. package Net::DBus::Test::MockIterator;
  66.  
  67.  
  68. use 5.006;
  69. use strict;
  70. use warnings;
  71.  
  72. sub _new {
  73.     my $proto = shift;
  74.     my $class = ref($proto) || $proto;
  75.     my $self = {};
  76.     my %params = @_;
  77.  
  78.     $self->{data} = exists $params{data} ? $params{data} : die "data parameter is required";
  79.     $self->{append} = exists $params{append} ? $params{append} : 0;
  80.     $self->{position} = 0;
  81.  
  82.     bless $self, $class;
  83.  
  84.     return $self;
  85. }
  86.  
  87. =item $res = $iter->has_next()
  88.  
  89. Determines if there are any more fields in the message
  90. itertor to be read. Returns a positive value if there
  91. are more fields, zero otherwise.
  92.  
  93. =cut
  94.  
  95. sub has_next {
  96.     my $self = shift;
  97.  
  98.     if ($self->{position} < $#{$self->{data}}) {
  99.     return 1;
  100.     }
  101.     return 0;
  102. }
  103.  
  104.  
  105. =item $success = $iter->next()
  106.  
  107. Skips the iterator onto the next field in the message.
  108. Returns a positive value if the current field pointer
  109. was successfully advanced, zero otherwise.
  110.  
  111. =cut
  112.  
  113. sub next {
  114.     my $self = shift;
  115.  
  116.     $self->{position}++;
  117.     if ($self->{position} <= $#{$self->{data}}) {
  118.     return 1;
  119.     }
  120.     return 0;
  121. }
  122.  
  123. =item my $val = $iter->get_boolean()
  124.  
  125. =item $iter->append_boolean($val);
  126.  
  127. Read or write a boolean value from/to the
  128. message iterator
  129.  
  130. =cut
  131.  
  132. sub get_boolean {
  133.     my $self = shift;
  134.     return $self->_get(&Net::DBus::Binding::Message::TYPE_BOOLEAN);
  135. }
  136.  
  137. sub append_boolean {
  138.     my $self = shift;
  139.     $self->_append(&Net::DBus::Binding::Message::TYPE_BOOLEAN, $_[0] ? 1 : "");
  140. }
  141.  
  142. =item my $val = $iter->get_byte()
  143.  
  144. =item $iter->append_byte($val);
  145.  
  146. Read or write a single byte value from/to the
  147. message iterator.
  148.  
  149. =cut
  150.  
  151. sub get_byte {
  152.     my $self = shift;
  153.     return $self->_get(&Net::DBus::Binding::Message::TYPE_BYTE);
  154. }
  155.  
  156. sub append_byte {
  157.     my $self = shift;
  158.     $self->_append(&Net::DBus::Binding::Message::TYPE_BYTE, $_[0]);
  159. }
  160.  
  161.  
  162. =item my $val = $iter->get_string()
  163.  
  164. =item $iter->append_string($val);
  165.  
  166. Read or write a UTF-8 string value from/to the
  167. message iterator
  168.  
  169.  
  170. =cut
  171.  
  172. sub get_string {
  173.     my $self = shift;
  174.     return $self->_get(&Net::DBus::Binding::Message::TYPE_STRING);
  175. }
  176.  
  177. sub append_string {
  178.     my $self = shift;
  179.     $self->_append(&Net::DBus::Binding::Message::TYPE_STRING, $_[0]);
  180. }
  181.  
  182. =item my $val = $iter->get_object_path()
  183.  
  184. =item $iter->append_object_path($val);
  185.  
  186. Read or write a UTF-8 string value, whose contents is
  187. a valid object path, from/to the message iterator
  188.  
  189.  
  190. =cut
  191.  
  192. sub get_object_path {
  193.     my $self = shift;
  194.     return $self->_get(&Net::DBus::Binding::Message::TYPE_OBJECT_PATH);
  195. }
  196.  
  197. sub append_object_path {
  198.     my $self = shift;
  199.     $self->_append(&Net::DBus::Binding::Message::TYPE_OBJECT_PATH, $_[0]);
  200. }
  201.  
  202. =item my $val = $iter->get_signature()
  203.  
  204. =item $iter->append_signature($val);
  205.  
  206. Read or write a UTF-8 string, whose contents is a 
  207. valid type signature, value from/to the message iterator
  208.  
  209.  
  210. =cut
  211.  
  212. sub get_signature {
  213.     my $self = shift;
  214.     return $self->_get(&Net::DBus::Binding::Message::TYPE_SIGNATURE);
  215. }
  216.  
  217. sub append_signature {
  218.     my $self = shift;
  219.     $self->_append(&Net::DBus::Binding::Message::TYPE_SIGNATURE, $_[0]);
  220. }
  221.  
  222. =item my $val = $iter->get_int16()
  223.  
  224. =item $iter->append_int16($val);
  225.  
  226. Read or write a signed 16 bit value from/to the
  227. message iterator
  228.  
  229.  
  230. =cut
  231.  
  232. sub get_int16 {
  233.     my $self = shift;
  234.     return $self->_get(&Net::DBus::Binding::Message::TYPE_INT16);
  235. }
  236.  
  237. sub append_int16 {
  238.     my $self = shift;
  239.     $self->_append(&Net::DBus::Binding::Message::TYPE_INT16, int($_[0]));
  240. }
  241.  
  242. =item my $val = $iter->get_uint16()
  243.  
  244. =item $iter->append_uint16($val);
  245.  
  246. Read or write an unsigned 16 bit value from/to the
  247. message iterator
  248.  
  249.  
  250. =cut
  251.  
  252. sub get_uint16 {
  253.     my $self = shift;
  254.     return $self->_get(&Net::DBus::Binding::Message::TYPE_UINT16);
  255. }
  256.  
  257. sub append_uint16 {
  258.     my $self = shift;
  259.     $self->_append(&Net::DBus::Binding::Message::TYPE_UINT16, int($_[0]));
  260. }
  261.  
  262. =item my $val = $iter->get_int32()
  263.  
  264. =item $iter->append_int32($val);
  265.  
  266. Read or write a signed 32 bit value from/to the
  267. message iterator
  268.  
  269.  
  270. =cut
  271.  
  272. sub get_int32 {
  273.     my $self = shift;
  274.     return $self->_get(&Net::DBus::Binding::Message::TYPE_INT32);
  275. }
  276.  
  277. sub append_int32 {
  278.     my $self = shift;
  279.     $self->_append(&Net::DBus::Binding::Message::TYPE_INT32, int($_[0]));
  280. }
  281.  
  282. =item my $val = $iter->get_uint32()
  283.  
  284. =item $iter->append_uint32($val);
  285.  
  286. Read or write an unsigned 32 bit value from/to the
  287. message iterator
  288.  
  289.  
  290. =cut
  291.  
  292. sub get_uint32 {
  293.     my $self = shift;
  294.     return $self->_get(&Net::DBus::Binding::Message::TYPE_UINT32);
  295. }
  296.  
  297. sub append_uint32 {
  298.     my $self = shift;
  299.     $self->_append(&Net::DBus::Binding::Message::TYPE_UINT32, int($_[0]));
  300. }
  301.  
  302. =item my $val = $iter->get_int64()
  303.  
  304. =item $iter->append_int64($val);
  305.  
  306. Read or write a signed 64 bit value from/to the
  307. message iterator. An error will be raised if this
  308. build of Perl does not support 64 bit integers
  309.  
  310.  
  311. =cut
  312.  
  313. sub get_int64 {
  314.     my $self = shift;
  315.     return $self->_get(&Net::DBus::Binding::Message::TYPE_INT64);
  316. }
  317.  
  318. sub append_int64 {
  319.     my $self = shift;
  320.     $self->_append(&Net::DBus::Binding::Message::TYPE_INT64, int($_[0]));
  321. }
  322.  
  323. =item my $val = $iter->get_uint64()
  324.  
  325. =item $iter->append_uint64($val);
  326.  
  327. Read or write an unsigned 64 bit value from/to the
  328. message iterator. An error will be raised if this
  329. build of Perl does not support 64 bit integers
  330.  
  331.  
  332. =cut
  333.  
  334. sub get_uint64 {
  335.     my $self = shift;
  336.     return $self->_get(&Net::DBus::Binding::Message::TYPE_UINT64);
  337. }
  338.  
  339. sub append_uint64 {
  340.     my $self = shift;
  341.     $self->_append(&Net::DBus::Binding::Message::TYPE_UINT64, int($_[0]));
  342. }
  343.  
  344. =item my $val = $iter->get_double()
  345.  
  346. =item $iter->append_double($val);
  347.  
  348. Read or write a double precision floating point value 
  349. from/to the message iterator
  350.  
  351. =cut
  352.  
  353. sub get_double {
  354.     my $self = shift;
  355.     return $self->_get(&Net::DBus::Binding::Message::TYPE_DOUBLE);
  356. }
  357.  
  358. sub append_double {
  359.     my $self = shift;
  360.     $self->_append(&Net::DBus::Binding::Message::TYPE_DOUBLE, $_[0]);
  361. }
  362.  
  363.  
  364.  
  365. =item my $value = $iter->get()
  366.  
  367. =item my $value = $iter->get($type);
  368.  
  369. Get the current value pointed to by this iterator. If the optional
  370. C<$type> parameter is supplied, the wire type will be compared with
  371. the desired type & a warning output if their differ. The C<$type>
  372. value must be one of the C<Net::DBus::Binding::Message::TYPE*>
  373. constants.
  374.  
  375. =cut
  376.  
  377. sub get {
  378.     my $self = shift;    
  379.     my $type = shift;
  380.  
  381.     if (defined $type) {
  382.     if (ref($type)) {
  383.         if (ref($type) eq "ARRAY") {
  384.         # XXX we should recursively validate types
  385.         $type = $type->[0];
  386.         if ($type eq &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) {
  387.             $type = &Net::DBus::Binding::Message::TYPE_ARRAY;
  388.         }
  389.         } else {
  390.         die "unsupport type reference $type";
  391.         }
  392.     }
  393.  
  394.     my $actual = $self->get_arg_type;
  395.     if ($actual != $type) {
  396.         # "Be strict in what you send, be leniant in what you accept"
  397.         #    - ie can't rely on python to send correct types, eg int32 vs uint32
  398.         #die "requested type '" . chr($type) . "' ($type) did not match wire type '" . chr($actual) . "' ($actual)";
  399.         warn "requested type '" . chr($type) . "' ($type) did not match wire type '" . chr($actual) . "' ($actual)";
  400.         $type = $actual;
  401.     }
  402.     } else {
  403.     $type = $self->get_arg_type;
  404.     }
  405.  
  406.     if ($type == &Net::DBus::Binding::Message::TYPE_STRING) {
  407.     return $self->get_string;
  408.     } elsif ($type == &Net::DBus::Binding::Message::TYPE_BOOLEAN) {
  409.     return $self->get_boolean;
  410.     } elsif ($type == &Net::DBus::Binding::Message::TYPE_BYTE) {
  411.     return $self->get_byte;
  412.     } elsif ($type == &Net::DBus::Binding::Message::TYPE_INT16) {
  413.     return $self->get_int16;
  414.     } elsif ($type == &Net::DBus::Binding::Message::TYPE_UINT16) {
  415.     return $self->get_uint16;
  416.     } elsif ($type == &Net::DBus::Binding::Message::TYPE_INT32) {
  417.     return $self->get_int32;
  418.     } elsif ($type == &Net::DBus::Binding::Message::TYPE_UINT32) {
  419.     return $self->get_uint32;
  420.     } elsif ($type == &Net::DBus::Binding::Message::TYPE_INT64) {
  421.     return $self->get_int64;
  422.     } elsif ($type == &Net::DBus::Binding::Message::TYPE_UINT64) {
  423.     return $self->get_uint64;
  424.     } elsif ($type == &Net::DBus::Binding::Message::TYPE_DOUBLE) {
  425.     return $self->get_double;
  426.     } elsif ($type == &Net::DBus::Binding::Message::TYPE_ARRAY) {
  427.     my $array_type = $self->get_element_type();
  428.     if ($array_type == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) {
  429.         return $self->get_dict();
  430.     } else {
  431.         return $self->get_array($array_type);
  432.     }
  433.     } elsif ($type == &Net::DBus::Binding::Message::TYPE_STRUCT) {
  434.     return $self->get_struct();
  435.     } elsif ($type == &Net::DBus::Binding::Message::TYPE_VARIANT) {
  436.     return $self->get_variant();
  437.     } elsif ($type == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) {
  438.     die "dictionary can only occur as part of an array type";
  439.     } elsif ($type == &Net::DBus::Binding::Message::TYPE_INVALID) {
  440.     die "cannot handle Net::DBus::Binding::Message::TYPE_INVALID";
  441.     } elsif ($type == &Net::DBus::Binding::Message::TYPE_OBJECT_PATH) {
  442.     return $self->get_object_path();
  443.     } elsif ($type == &Net::DBus::Binding::Message::TYPE_SIGNATURE) {
  444.     return $self->get_signature();
  445.     } else {
  446.     die "unknown argument type '" . chr($type) . "' ($type)";
  447.     }
  448. }
  449.  
  450. =item my $hashref = $iter->get_dict()
  451.  
  452. If the iterator currently points to a dictionary value, unmarshalls
  453. and returns the value as a hash reference. 
  454.  
  455. =cut
  456.  
  457. sub get_dict {
  458.     my $self = shift;
  459.  
  460.     my $iter = $self->_recurse();
  461.     my $type = $iter->get_arg_type();
  462.     my $dict = {};
  463.     while ($type == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) {
  464.     my $entry = $iter->get_struct();
  465.     if ($#{$entry} != 1) {
  466.         die "Dictionary entries must be structs of 2 elements. This entry has " . ($#{$entry}+1) ." elements";
  467.     }
  468.     
  469.     $dict->{$entry->[0]} = $entry->[1];
  470.     $iter->next();
  471.     $type = $iter->get_arg_type();
  472.     }
  473.     return $dict;
  474. }
  475.  
  476. =item my $hashref = $iter->get_array()
  477.  
  478. If the iterator currently points to an array value, unmarshalls
  479. and returns the value as a array reference. 
  480.  
  481. =cut
  482.  
  483. sub get_array {
  484.     my $self = shift;
  485.     my $array_type = shift;
  486.  
  487.     my $iter = $self->_recurse();
  488.     my $type = $iter->get_arg_type();
  489.     my $array = [];
  490.     while ($type != &Net::DBus::Binding::Message::TYPE_INVALID) {
  491.     if ($type != $array_type) {
  492.         die "Element $type not of array type $array_type";
  493.     }
  494.  
  495.     my $value = $iter->get($type);
  496.     push @{$array}, $value;
  497.     $iter->next();
  498.     $type = $iter->get_arg_type();
  499.     }
  500.     return $array;
  501. }
  502.  
  503. =item my $hashref = $iter->get_variant()
  504.  
  505. If the iterator currently points to a variant value, unmarshalls
  506. and returns the value contained in the variant.
  507.  
  508. =cut
  509.  
  510. sub get_variant {
  511.     my $self = shift;
  512.  
  513.     my $iter = $self->_recurse();
  514.     return $iter->get();
  515. }
  516.  
  517.  
  518. =item my $hashref = $iter->get_struct()
  519.  
  520. If the iterator currently points to an struct value, unmarshalls
  521. and returns the value as a array reference. The values in the array 
  522. correspond to members of the struct.
  523.  
  524. =cut
  525.  
  526. sub get_struct {
  527.     my $self = shift;
  528.  
  529.     my $iter = $self->_recurse();
  530.     my $type = $iter->get_arg_type();
  531.     my $struct = [];
  532.     while ($type != &Net::DBus::Binding::Message::TYPE_INVALID) {
  533.     my $value = $iter->get($type);
  534.     push @{$struct}, $value;
  535.     $iter->next();
  536.     $type = $iter->get_arg_type();
  537.     }
  538.     return $struct;
  539. }
  540.  
  541. =item $iter->append($value)
  542.  
  543. =item $iter->append($value, $type)
  544.  
  545. Appends a value to the message associated with this iterator. The
  546. value is marshalled into wire format, according to the following
  547. rules.
  548.  
  549. If the C<$value> is an instance of L<Net::DBus::Binding::Value>,
  550. the embedded data type is used.
  551.  
  552. If the C<$type> parameter is supplied, that is taken to represent
  553. the data type. The type must be one of the C<Net::DBus::Binding::Message::TYPE_*>
  554. constants.
  555.  
  556. Otherwise, the data type is chosen to be a string, dict or array
  557. according to the perl data types SCALAR, HASH or ARRAY.
  558.  
  559. =cut
  560.  
  561. sub append {
  562.     my $self = shift;
  563.     my $value = shift;
  564.     my $type = shift;
  565.  
  566.     if (ref($value) eq "Net::DBus::Binding::Value" &&
  567.         ((! defined ref($type)) ||
  568.      (ref($type) ne "ARRAY") ||
  569.      $type->[0] != &Net::DBus::Binding::Message::TYPE_VARIANT)) {
  570.     $type = $value->type;
  571.     $value = $value->value;
  572.     }
  573.  
  574.     if (!defined $type) {
  575.     $type = $self->guess_type($value);
  576.     }
  577.  
  578.     if (ref($type) eq "ARRAY") {
  579.     my $maintype = $type->[0];
  580.     my $subtype = $type->[1];
  581.  
  582.     if ($maintype == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) {
  583.         $self->append_dict($value, $subtype);
  584.     } elsif ($maintype == &Net::DBus::Binding::Message::TYPE_STRUCT) {
  585.         $self->append_struct($value, $subtype);
  586.     } elsif ($maintype == &Net::DBus::Binding::Message::TYPE_ARRAY) {
  587.         $self->append_array($value, $subtype);
  588.     } elsif ($maintype == &Net::DBus::Binding::Message::TYPE_VARIANT) {
  589.         $self->append_variant($value, $subtype);
  590.     } else {
  591.         die "Unsupported compound type ", $maintype, " ('", chr($maintype), "')";
  592.     }
  593.     } else {
  594.     # XXX is this good idea or not
  595.     $value = '' unless defined $value;
  596.  
  597.     if ($type == &Net::DBus::Binding::Message::TYPE_BOOLEAN) {
  598.         $self->append_boolean($value);
  599.     } elsif ($type == &Net::DBus::Binding::Message::TYPE_BYTE) {
  600.         $self->append_byte($value);
  601.     } elsif ($type == &Net::DBus::Binding::Message::TYPE_STRING) {
  602.         $self->append_string($value);
  603.     } elsif ($type == &Net::DBus::Binding::Message::TYPE_INT16) {
  604.         $self->append_int16($value);
  605.     } elsif ($type == &Net::DBus::Binding::Message::TYPE_UINT16) {
  606.         $self->append_uint16($value);
  607.     } elsif ($type == &Net::DBus::Binding::Message::TYPE_INT32) {
  608.         $self->append_int32($value);
  609.     } elsif ($type == &Net::DBus::Binding::Message::TYPE_UINT32) {
  610.         $self->append_uint32($value);
  611.     } elsif ($type == &Net::DBus::Binding::Message::TYPE_INT64) {
  612.         $self->append_int64($value);
  613.     } elsif ($type == &Net::DBus::Binding::Message::TYPE_UINT64) {
  614.         $self->append_uint64($value);
  615.     } elsif ($type == &Net::DBus::Binding::Message::TYPE_DOUBLE) {
  616.         $self->append_double($value);
  617.     } elsif ($type == &Net::DBus::Binding::Message::TYPE_OBJECT_PATH) {
  618.         $self->append_object_path($value);
  619.     } elsif ($type == &Net::DBus::Binding::Message::TYPE_SIGNATURE) {
  620.         $self->append_signature($value);
  621.     } else {
  622.         die "Unsupported scalar type ", $type, " ('", chr($type), "')";
  623.     }
  624.     }
  625. }
  626.  
  627.  
  628. =item my $type = $iter->guess_type($value)
  629.  
  630. Make a best guess at the on the wire data type to use for 
  631. marshalling C<$value>. If the value is a hash reference,
  632. the dictionary type is returned; if the value is an array
  633. reference the array type is returned; otherwise the string
  634. type is returned.
  635.  
  636. =cut
  637.  
  638. sub guess_type {
  639.     my $self = shift;
  640.     my $value = shift;
  641.  
  642.     if (ref($value)) {
  643.     if (UNIVERSAL::isa($value, "Net::DBus::Binding::Value")) {
  644.         my $type = $value->type;
  645.         if (ref($type) && ref($type) eq "ARRAY") {
  646.         my $maintype = $type->[0];
  647.         my $subtype = $type->[1];
  648.  
  649.         if (!defined $subtype) {
  650.             if ($maintype == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) {
  651.             $subtype = [ $self->guess_type(($value->value())[0]->[0]), 
  652.                      $self->guess_type(($value->value())[0]->[1]) ];
  653.             } elsif ($maintype == &Net::DBus::Binding::Message::TYPE_ARRAY) {
  654.             $subtype = [ $self->guess_type(($value->value())[0]->[0]) ];
  655.             } elsif ($maintype == &Net::DBus::Binding::Message::TYPE_STRUCT) {
  656.             $subtype = [ map { $self->guess_type($_) } @{($value->value())[0]} ];
  657.             } else {
  658.             die "Unguessable compound type '$maintype' ('", chr($maintype), "')\n";
  659.             }
  660.         }
  661.         return [$maintype, $subtype];
  662.         } else {
  663.         return $type;
  664.         }
  665.     } elsif (ref($value) eq "HASH") {
  666.         my $key = (keys %{$value})[0];
  667.         my $val = $value->{$key};
  668.         # XXX Basically impossible to decide between DICT & STRUCT
  669.         return [ &Net::DBus::Binding::Message::TYPE_DICT_ENTRY,
  670.              [ &Net::DBus::Binding::Message::TYPE_STRING, $self->guess_type($val)] ];
  671.     } elsif (ref($value) eq "ARRAY") {
  672.         return [ &Net::DBus::Binding::Message::TYPE_ARRAY,
  673.              [$self->guess_type($value->[0])] ];
  674.     } else {
  675.         die "cannot marshall reference of type " . ref($value);
  676.     }
  677.     } else {
  678.     # XXX Should we bother trying to guess integer & floating point types ?
  679.     # I say sod it, because strongly typed languages will support introspection
  680.     # and loosely typed languages won't care about the difference
  681.     return &Net::DBus::Binding::Message::TYPE_STRING;
  682.     }
  683. }
  684.  
  685. =item my $sig = $iter->format_signature($type)
  686.  
  687. Given a data type representation, construct a corresponding 
  688. signature string
  689.  
  690. =cut
  691.  
  692. sub format_signature {
  693.     my $self = shift;
  694.     my $type = shift;
  695.     my ($sig, $t, $i);
  696.  
  697.     $sig = "";
  698.     $i = 0;use Data::Dumper;
  699.  
  700.     if (ref($type) eq "ARRAY") {
  701.     while ($i <= $#{$type}) {
  702.         $t = $$type[$i];
  703.         
  704.         if (ref($t) eq "ARRAY") {
  705.         $sig .= $self->format_signature($t);
  706.         } elsif ($t == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) {
  707.         $sig .= chr (&Net::DBus::Binding::Message::TYPE_ARRAY);
  708.         $sig .= "{" . $self->format_signature($$type[++$i]) . "}";
  709.         } elsif ($t == &Net::DBus::Binding::Message::TYPE_STRUCT) {
  710.         $sig .= "(" . $self->format_signature($$type[++$i]) . ")";
  711.         } else {
  712.         $sig .= chr($t);
  713.         }
  714.         
  715.         $i++;
  716.     }
  717.     } else {
  718.     $sig .= chr ($type);
  719.     }
  720.     
  721.     return $sig;
  722. }
  723.  
  724. =item $iter->append_array($value, $type)
  725.  
  726. Append an array of values to the message. The C<$value> parameter
  727. must be an array reference, whose elements all have the same data
  728. type specified by the C<$type> parameter.
  729.  
  730. =cut
  731.  
  732. sub append_array {
  733.     my $self = shift;
  734.     my $array = shift;
  735.     my $type = shift;
  736.     
  737.     if (!defined($type)) {
  738.     $type = [$self->guess_type($array->[0])];
  739.     }
  740.  
  741.     die "array must only have one type"
  742.     if $#{$type} > 0;
  743.  
  744.     my $sig = $self->format_signature($type);
  745.     my $iter = $self->_open_container(&Net::DBus::Binding::Message::TYPE_ARRAY, $sig);
  746.     
  747.     foreach my $value (@{$array}) {
  748.     $iter->append($value, $type->[0]);
  749.     }
  750. }
  751.  
  752.  
  753. =item $iter->append_struct($value, $type)
  754.  
  755. Append a struct to the message. The C<$value> parameter
  756. must be an array reference, whose elements correspond to
  757. members of the structure. The C<$type> parameter encodes
  758. the type of each member of the struct.
  759.  
  760. =cut
  761.  
  762. sub append_struct {
  763.     my $self = shift;
  764.     my $struct = shift;
  765.     my $type = shift;
  766.  
  767.     if (defined($type) &&
  768.     $#{$struct} != $#{$type}) {
  769.     die "number of values does not match type";
  770.     }
  771.  
  772.     my $iter = $self->_open_container(&Net::DBus::Binding::Message::TYPE_STRUCT, "");
  773.     
  774.     my @type = defined $type ? @{$type} : ();
  775.     foreach my $value (@{$struct}) {
  776.     $iter->append($value, shift @type);
  777.     }
  778. }
  779.  
  780. =item $iter->append_dict($value, $type)
  781.  
  782. Append a dictionary to the message. The C<$value> parameter
  783. must be an hash reference.The C<$type> parameter encodes
  784. the type of the key and value of the hash.
  785.  
  786. =cut
  787.  
  788. sub append_dict {
  789.     my $self = shift;
  790.     my $hash = shift;
  791.     my $type = shift;
  792.  
  793.     my $sig;
  794.  
  795.     $sig  = "{";
  796.     $sig .= $self->format_signature($type);
  797.     $sig .= "}";
  798.  
  799.     my $iter = $self->_open_container(&Net::DBus::Binding::Message::TYPE_ARRAY, $sig);
  800.     
  801.     foreach my $key (keys %{$hash}) {
  802.     my $value = $hash->{$key};
  803.     my $entry = $iter->_open_container(&Net::DBus::Binding::Message::TYPE_DICT_ENTRY, $sig);
  804.  
  805.     $entry->append($key, $type->[0]);
  806.     $entry->append($value, $type->[1]);
  807.     }
  808. }
  809.  
  810. =item $iter->append_variant($value)
  811.  
  812. Append a value to the message, encoded as a variant type. The
  813. C<$value> can be of any type, however, the variant will be
  814. encoded as either a string, dictionary or array according to
  815. the rules of the C<guess_type> method.
  816.  
  817. =cut
  818.  
  819. sub append_variant {
  820.     my $self = shift;
  821.     my $value = shift;
  822.     my $type = shift;
  823.  
  824.     if (UNIVERSAL::isa($value, "Net::DBus::Binding::Value")) {
  825.     $type = [$self->guess_type($value)];
  826.     $value = $value->value;
  827.     } elsif (!defined $type || !defined $type->[0]) {
  828.     $type = [$self->guess_type($value)];
  829.     }
  830.     die "variant must only have one type"
  831.     if defined $type && $#{$type} > 0;
  832.  
  833.     my $sig = $self->format_signature($type->[0]);
  834.     my $iter = $self->_open_container(&Net::DBus::Binding::Message::TYPE_VARIANT, $sig);
  835.     $iter->append($value, $type->[0]);
  836. }
  837.  
  838.  
  839. =item my $type = $iter->get_arg_type
  840.  
  841. Retrieves the type code of the value pointing to by this iterator.
  842. The returned code will correspond to one of the constants
  843. C<Net::DBus::Binding::Message::TYPE_*>
  844.  
  845. =cut
  846.  
  847. sub get_arg_type {
  848.     my $self = shift;
  849.  
  850.     return &Net::DBus::Binding::Message::TYPE_INVALID
  851.     if $self->{position} > $#{$self->{data}};
  852.  
  853.     my $data = $self->{data}->[$self->{position}];
  854.     return $data->[0];
  855. }
  856.  
  857. =item my $type = $iter->get_element_type
  858.  
  859. If the iterator points to an array, retrieves the type code of 
  860. array elements. The returned code will correspond to one of the 
  861. constants C<Net::DBus::Binding::Message::TYPE_*>
  862.  
  863. =cut
  864.  
  865. sub get_element_type {
  866.     my $self = shift;
  867.     
  868.     die "current element is not valid" if $self->{position} > $#{$self->{data}};
  869.  
  870.     my $data = $self->{data}->[$self->{position}];
  871.     if ($data->[0] != &Net::DBus::Binding::Message::TYPE_ARRAY) {
  872.     die "current element is not an array";
  873.     }
  874.     return $data->[1]->[0]->[0];
  875. }
  876.  
  877.  
  878.  
  879. sub _recurse {
  880.     my $self = shift;
  881.  
  882.     die "_recurse call is not valid for writable iterator" if $self->{append};
  883.  
  884.     die "current element is not valid" if $self->{position} > $#{$self->{data}};
  885.  
  886.     my $data = $self->{data}->[$self->{position}];
  887.  
  888.     my $type = $data->[0];
  889.     if ($type != &Net::DBus::Binding::Message::TYPE_STRUCT &&
  890.     $type != &Net::DBus::Binding::Message::TYPE_ARRAY &&
  891.     $type != &Net::DBus::Binding::Message::TYPE_DICT_ENTRY &&
  892.     $type != &Net::DBus::Binding::Message::TYPE_VARIANT) {
  893.     die "current data element '$type' is not a container";
  894.     }
  895.  
  896.     return $self->_new(data => $data->[1],
  897.                append => 0);
  898. }
  899.  
  900.  
  901. sub _append {
  902.     my $self = shift;
  903.     my $type = shift;
  904.     my $data = shift;
  905.  
  906.     die "iterator is not open for append" unless $self->{append};
  907.  
  908.     push @{$self->{data}}, [$type, $data];
  909. }
  910.  
  911.  
  912. sub _open_container {
  913.     my $self = shift;
  914.     my $type = shift;
  915.     my $sig = shift;
  916.  
  917.     my $data = [];
  918.  
  919.     push @{$self->{data}}, [$type, $data, $sig];
  920.  
  921.     return $self->_new(data => $data,
  922.                append => 1);
  923. }
  924.  
  925.  
  926.  
  927. sub _get {
  928.     my $self = shift;
  929.     my $type = shift;
  930.  
  931.     die "iterator is not open for reading" if $self->{append};
  932.  
  933.     die "current element is not valid" if $self->{position} > $#{$self->{data}};
  934.  
  935.     my $data = $self->{data}->[$self->{position}];
  936.  
  937.     die "data type does not match" unless $data->[0] == $type;
  938.  
  939.     return $data->[1];
  940. }
  941.  
  942. 1;
  943.  
  944. =pod
  945.  
  946. =back
  947.  
  948. =head1 BUGS
  949.  
  950. It doesn't completely replicate the API of L<Net::DBus::Binding::Iterator>,
  951. merely enough to make the high level bindings work in a test scenario.
  952.  
  953. =head1 SEE ALSO
  954.  
  955. L<Net::DBus::Test::MockMessage>, L<Net::DBus::Binding::Iterator>,
  956. L<http://www.mockobjects.com/Faq.html>
  957.  
  958. =head1 COPYRIGHT
  959.  
  960. Copyright 2006 Daniel Berrange <dan@berrange.com>
  961.  
  962. =cut
  963.